#lang racket


(require "../base/main.rkt")

(require (prefix-in mar: "ac-marshall.rkt"))

(provide (rename-out (mar:load-autocad-marshall load-autocad-imediate))
         
         ; primitives
         arc
         elliptical-arc
         circle
         donut
         ellipse
         helix-2d
         line
         ngon
         nurbs-curve
         nurbs-surface
         rectangle
         spline
         star
         ;text
         
         box
         cone
         cone-frustrum
         cylinder
         pipe
         sphere
         
         ; operations
         extrude
         intersect
         join
         loft
         move
         offset
         rotate
         scale
         subtract
         sweep
         union
         
         ; lang
         curve
         surface
         
         on-left
         on-right
         on-x
         on-front
         on-back
         on-y
         on-top
         on-bottom
         on-z
         
         ; autocad
         arc-ppp
         
         (rename-out (mar:arc? arc?)
                     (mar:get-arc-center get-arc-center)
                     (mar:get-arc-begin-angle get-arc-begin-angle)
                     (mar:get-arc-end-angle get-arc-end-angle)
                     (mar:get-arc-radius get-arc-radius)
                     
                     (mar:begin-undo-mark begin-undo-mark)
                     (mar:end-undo-mark end-undo-mark)
                     (mar:get-object-name get-object-name)
                     (mar:redo redo)
                     (mar:redraw redraw)
                     (mar:undo undo)))


; primitives

(define (arc angle radius)
  (mar:add-arc zero radius 0 angle))

(define (elliptical-arc angle x-radius y-radius)
  (error 'elliptical-arc "Not implemented"))

(define (circle radius)
  (mar:add-circle zero radius))

(define (donut inner-radius outer-radius)
  (error 'donut "Not implemented"))

(define (ellipse x-radius y-radius)
  (mar:add-ellipse
   zero
   x-radius
   (/ x-radius y-radius)))

(define (helix-2d base-radius top-radius turns turn-height direction)
  (error 'helix-2d "Not implemented"))

(define (line points)
  (if (= (length points) 2)
      (mar:add-line (first points) (second points))
      (mar:add-polyline points)))

(define (ngon width sides)
  (error 'ngon "Not implemented"))

(define (nurbs-curve controls knots)
  (error 'nurbs-curve "Not implemented"))

(define (nurbs-surface controls u-knots v-knots)
  (error 'nurbs-surface "Not implemented"))

(define (rectangle width length)
  (error 'rectangle "Not implemented"))

(define (spline points)
  (let* ((c0 (first points))
         (c1 (second points))
         (c2 (second (reverse points)))
         (c3 (first (last points)))
         (start-tangent (p-p c1 c0))
         (end-tangent (p-p c3 c2)))
    (mar:add-spline points start-tangent end-tangent)))

(define (star width sides stride)
  (error 'star "Not implemented"))

;(define (text text)
;  (make-text-node text))


(define (box width length height)
  (mar:add-box zero width length height))

(define (cone radius height)
  (mar:add-cone
   (p*n uz (/ height 2.0))
   radius
   height))

(define (cone-frustrum base-radius top-radius height)
  (mar:add-cone-frustrum
   zero
   base-radius
   top-radius
   height))

(define (cylinder radius height)
  (mar:add-cylinder
   (p*n uz (/ height 2.0))
   radius
   height))

;(define (elliptical-cone x-radius y-radius height))
;(define (gengon width sides fillet-width height))
;(define (helix-3d base-radius top-radius section-radius turns turn-height direction))
;(define (mesh vertices faces))
;(define (paraboloid radius height))

; edit: code duplicated from support module
(define (pipe inner-radius outer-radius height)
  (subtract
   (cylinder outer-radius height)
   (cylinder inner-radius height)))

;(define (platonic-solids width sides))
;(define (pyramid width sides height))

(define (sphere radius)
  (mar:add-sphere zero radius))

;(define (spindle radius height))
;(define (superellipsoid width length height))
;(define (torus base-radius section-radius))
;(define (truncated-icosahedron width))
;(define (wedge width height))


; operations

(define (extrude length surface)
  (mar:add-extruded-solid
   (first (mar:add-region (list surface)))
   length
   0))

;(define (guide-loft guide shapes))

(define intersect
  (case-lambda
    ((shape1 shape2)
     (mar:intersect shape1 shape2))
    ((shapes)
     (foldl mar:intersect shapes))
    (shapes
     (foldl mar:intersect shapes))))

;(define (lattice shape))

(define (join shapes)
  (mar:join shapes))

(define (loft closed shapes)
  (mar:loft closed shapes))

;(define (mirror plane shape))


; move

;(define (make-move-transformation transformation position shape)
;  (m*m
;   (apply m.translate (list<-point position))
;   transformation))

(define (move position shape)
  (mar:move shape zero position))

; /move


; offset

(define (offset distance shape)
  (mar:offset shape distance))

;(define (path-loft path shapes))
;(define (revolve axis shape))


; rotate

;(define (make-rotate-transformation transformation angle normal)
;  (m*m transformation (apply m.rotate angle (list<-point normal))))

(define (rotate angle normal shape)
  (if (or (= angle 0) (zero? normal))
      shape
      (mar:rotate3d shape zero normal angle)))

; /rotate


(define (scale scale shape)
  (mar:scale shape scale))

;(define (slice plane shape))

; edit: contract different from Rhino: which one makes sense?
(define subtract
  (case-lambda
    ((shape1 shape2)
     (if (list? shape2)
         (mar:subtract shape1 (foldl mar:subtract shape2))
         (mar:subtract shape1 shape2)))
    (shapes
     (mar:subtract (first shapes) (foldl mar:subtract (rest shapes))))))

(define (sweep shape path)
  (mar:sweep shape path))

;(define (thicken length shape))

(define union
  (case-lambda
    ((shape1 shape2)
     (mar:union shape1 shape2))
    ((shapes)
     (reduce mar:union shapes))
    (shapes
     (reduce mar:union shapes))))


; lang

(define (curve shape)
  (error 'curve "Not implemented"))

(define (surface shape)
  (error 'surface "Not implemented"))

(define (on-left . args)
  (error 'on-left "Not implemented"))

(define (on-right . args)
  (error 'on-right "Not implemented"))

(define (on-x . args)
  (error 'on-x "Not implemented"))

(define (on-front . args)
  (error 'on-front "Not implemented"))

(define (on-back . args)
  (error 'on-back "Not implemented"))

(define (on-y . args)
  (error 'on-y "Not implemented"))

(define on-top
  (case-lambda
    ((shape1 shape2)
     (error "ontop: Not implemented"))
    ((shapes)
     (error "ontop: Not implemented"))
    (shapes
     (error "ontop: Not implemented"))))

(define (on-bottom . args)
  (error 'on-bottom "Not implemented"))

(define (on-z . args)
  (error 'on-z "Not implemented"))


; autocad

(define (arc-ppp p1 p2 p3)
  (mar:add-arc-ppp p1 p2 p3))